﻿<%
'''Json对象类
Class AshapoJson
	
	'''是否以字面编码多字节 Unicode 字符
	Private s_UnescapedUnicode
	
	'''是否所有的 " 转换成 \u0022
	Private s_HexQuot
	
	'''是否所有的 & 转换成 \u0026
	Private s_HexAmp
	
	'''是否所有的 ' 转换成 \u0027
	Private s_HexApos
	
	'''是否所有的 < 和 > 转换成 \u003C 和 \u003E
	Private s_HexTag
	
	'''不要编码/
	Private s_UnescapedSlashes
	
	'''内部使用的AshapoConfig对象
	Private s_cfg

	'''解析JSON时使用的ScriptControl
	Private s_scriptCtrl
	
	'''构造
	Private Sub Class_Initialize()	
		s_HexQuot = False
		s_HexAmp = False
		s_HexApos = False
		s_HexTag = False
		s_UnescapedSlashes = False
		s_UnescapedUnicode = False
		
		Set s_cfg = New AshapoConfig
	End Sub
	
	'''析构
	Private Sub Class_Terminate()
		Set s_cfg = Nothing
	End Sub
	
	'''设置是否以字面编码多字节 Unicode 字符
	'p_bool:布尔值
	Public Property Let UnescapedUnicode(Byval p_bool)
		s_UnescapedUnicode = p_bool
	End Property
	
	'''设置是否所有的 " 转换成 \u0022
	'p_bool:布尔值
	Public Property Let HexQuot(Byval p_bool)
		s_HexQuot = p_bool
	End Property
	
	'''设置是否所有的 & 转换成 \u0026
	'p_bool:布尔值
	Public Property Let HexAmp(Byval p_bool)
		s_HexAmp = p_bool
	End Property
	
	'''设置是否所有的 ' 转换成 \u0027
	'p_bool:布尔值
	Public Property Let HexApos(Byval p_bool)
		s_HexApos = p_bool
	End Property
	
	'''设置是否所有的 < 和 > 转换成 \u003C 和 \u003E
	'p_bool:布尔值
	Public Property Let HexTag(Byval p_bool)
		s_HexTag = p_bool
	End Property
	
	'''设置是否不要编码/
	'p_bool:布尔值
	Public Property Let UnescapedSlashes(Byval p_bool)
		s_UnescapedSlashes = p_bool
	End Property
	
	'''编码字符串
	Private Function [escape](Byval p_str)
		'On Error Resume Next
		If s_UnescapedUnicode Then
			escape = p_str
			'''双引号处理
			If s_HexQuot Then
				escape = Replace(escape, """", "\u0022")
			Else
				escape = Replace(escape, """", "\""")
			End If
			'''&符号处理
			If s_HexQuot Then
				escape = Replace(escape, "&", "\u0026")
			End If
			'''单引号处理
			If s_HexApos Then
				escape = Replace(escape, "'", "\u0027")
			End If
			'''大于号、小于号处理
			If s_HexTag Then
				escape = Replace(escape, "<", "\u003C")
				escape = Replace(escape, ">", "\u003E")
			End If
			'''编码/
			If Not s_UnescapedSlashes Then
				escape = Replace(escape, "/", "\/")
			End If
		Else
			Dim t_scriptCtrl
			Set t_scriptCtrl = Server.CreateObject( s_cfg.Environment("MSScriptControl.ScriptControl") )
			t_scriptCtrl.Language = "JScript"
			t_scriptCtrl.AddCode("var result = null;")
			t_scriptCtrl.ExecuteStatement("result = escape(""" & Replace(p_str, """", "\""") & """).replace(/%u/gi, '\\u');")
			escape = t_scriptCtrl.CodeObject.result
			
			'Die(TypeName(escape))
			
			
			'''处理不需要编译字符
			escape = Replace(escape, "%20", " ") ''空格
			escape = Replace(escape, "%21", "!") ''感叹号
			'''双引号处理
			If s_HexQuot Then
				escape = Replace(escape, "%22", "\u0022")
			Else
				escape = Replace(escape, "%22", "\""")
			End If
			escape = Replace(escape, "%23", "#") ''井号
			escape = Replace(escape, "%24", "$") ''美元符号
			escape = Replace(escape, "%25", "%") ''百分号
			'''&符号处理
			If s_HexQuot Then
				escape = Replace(escape, "%26", "\u0026")
			Else
				escape = Replace(escape, "%26", "&")
			End If
			'''单引号处理
			If s_HexApos Then
				escape = Replace(escape, "%27", "\u0027")
			Else
				escape = Replace(escape, "%27", "'")
			End If
			escape = Replace(escape, "%28", "(") ''左括号
			escape = Replace(escape, "%29", ")") ''右括号
			escape = Replace(escape, "%2C", ",") ''逗号
			If Not s_UnescapedSlashes Then
				escape = Replace(escape, "/", "\/")
			End If
			escape = Replace(escape, "%3A", ":") ''冒号
			escape = Replace(escape, "%3B", ";") ''分号
			'''小于号处理
			If s_HexTag Then
				escape = Replace(escape, "%3C", "\u003C")
			Else
				escape = Replace(escape, "%3C", "<")
			End If
			escape = Replace(escape, "%3D", "=") ''等号
			'''大于号处理
			If s_HexTag Then
				escape = Replace(escape, "%3E", "\u003E")
			Else
				escape = Replace(escape, "%3E", ">")
			End If
			escape = Replace(escape, "%3F", "?") ''问号
			escape = Replace(escape, "%5B", "[") ''[符号
			escape = Replace(escape, "%5C", "\\") ''\符号
			escape = Replace(escape, "%5D", "]") ''[符号
			escape = Replace(escape, "%5E", "^") ''^符号
			escape = Replace(escape, "%60", "`") ''`符号
			escape = Replace(escape, "%7B", "{") ''{符号
			escape = Replace(escape, "%7C", "|") ''|符号
			escape = Replace(escape, "%7D", "}") ''}符号
			escape = Replace(escape, "%7E", "~") ''~符号
		End If
		If Err.Number <> 0 Then
			escape = ""
		End If
	End Function
	
	'''将Dictionary对象或数组编译成json字符串
	Public Function [Encode](Byval p_objt)
		Dim t_i, t_b, t_left, t_right, t_mid
		If IsArray(p_objt) Then ''数组
			t_left = "["
			t_right = "]"
			t_mid = ""
			t_b = UBound(p_objt)
			For t_i = 0 To t_b
				t_mid = t_mid & [Encode](p_objt(t_i))
				If t_i < t_b Then
					t_mid = t_mid & ","
				End If
			Next
		ElseIf TypeName(p_objt) = "Dictionary" Then ''对象
			t_left = "{"
			t_right = "}"
			t_mid = ""
			t_b = p_objt.Count - 1
			Dim t_k, t_v
			t_k = p_objt.Keys
			t_v = p_objt.Items
			For t_i = 0 To t_b
				t_mid = t_mid & """" & t_k(t_i) & """" & ":"
				'Response.Write(t_v(t_i))
				t_mid = t_mid & [Encode](t_v(t_i))
				If t_i < t_b Then
					t_mid = t_mid & ","
				End If
			Next
		Else ''标量
			t_left = ""
			t_right = ""
			t_mid = ""
			Select Case VarType(p_objt)
			Case VbNull
				t_mid = "null"
			Case VbInteger, VbLong, VbSingle, VbDouble
				t_mid = Cstr(p_objt)
			Case VbCurrency, VbDate, VbString
				t_mid = """" & escape(p_objt) & """"
			Case vbBoolean
				t_mid = IIF(p_objt, "true", "false")
			Case Else
				
				'''todo 待修改
				'Die(TypeName(p_objt))
				''出错
				Die("JSON Encode ERROR:" & VarType(p_objt))
				Exit Function
			End Select
		End If
		[Encode] = t_left & t_mid & t_right
	End Function

	'''将一个符合JSON标准的字符串类型转化为ASP对象
	Private Sub initScriptCtrl(Byval p_string)
		'On Error Resume Next
		Set s_scriptCtrl = Server.CreateObject("MSScriptControl.ScriptControl")
		s_scriptCtrl.Language = "JScript"
		s_scriptCtrl.AddCode("Object.prototype.get = function(x){return this[x];};")
		s_scriptCtrl.AddCode("Object.prototype.isArray = function(){return this instanceof Array;};")
		's_scriptCtrl.AddCode("Object.prototype.isDictionary = function(){var isjson = typeof(this) == 'object'&& Object.prototype.toString.call(this).toLowerCase() == '[object object]'' && !this.length; return isjson;};")
		s_scriptCtrl.AddCode("Object.prototype.keys = function(){var arr=[]; for(var key in this){if(key!='keys' && key!='get' && key!='isArray'){arr.push(key);};}; return arr;};")
		s_scriptCtrl.AddCode("Array.prototype.keys = function(){var arr=[]; for(var key in this){if(key!='keys' && key!='get' && key!='isArray'){arr.push(key);};}; return arr;};")
		s_scriptCtrl.AddCode("var result = null;")  ''完整获取
		s_scriptCtrl.AddCode("var item = null;")  ''局部获取
		Dim t_code : t_code = "result = " & p_string & ";"
		s_scriptCtrl.ExecuteStatement(t_code)
		'Call assign( toVbOjbect, t_scriptCtrl.CodeObject.result )
	End Sub

	'''通过原生PATH获取JScriptTypeInfo格式
	'p_path:对当前scriptCtrl使用的get方法参数值
	Private Function getItem_(Byval p_path)
		'Response.Write(p_path & "<br/>")
		Dim t_code : t_code = "item = result" & p_path & ";"
		s_scriptCtrl.ExecuteStatement(t_code)
		If IsObject( s_scriptCtrl.CodeObject.item ) Then
			Dim t_object : Set t_object = s_scriptCtrl.CodeObject.item
			If t_object.isArray() Then ''作为数组处理
				Dim t_keys1, t_arr1(), t_path1, t_temp1
				Set t_keys1 = t_object.keys()
				ReDim t_arr1(t_keys1.length-1)
				For t_i = 0 To t_keys1.length-1
					t_path1 = p_path & "[" & Cstr(t_i) & "]"
					Call assign( t_temp1, getItem_(t_path1) )
					If IsObject(t_temp1) Then
						Set t_arr1(t_i) = t_temp1
					Else
						t_arr1(t_i) = t_temp1
					End If
				Next
				getItem_ = t_arr1
			Else ''作为Dictionary处理
				Dim t_item : Set t_item = Server.CreateObject( s_cfg.Environment("Scripting.Dictionary") )
				Dim t_keys2, t_obj_val, t_obj_key, t_path2, t_temp2
				Set t_keys2 = t_object.keys()
				For t_i = 0 To t_keys2.length-1
					t_obj_key = t_keys2.get(t_i)
					t_path2 = p_path & "[""" & Replace(t_obj_key, """", "\""") & """]"
					Call assign( t_temp2, getItem_(t_path2) )
					If IsObject(t_temp2) Then
						Set t_item(t_obj_key) = t_temp2
					Else
						t_item(t_obj_key) = t_temp2
					End If
				Next
				Set getItem_ = t_item
			End If
		Else
			'''标量直接返回
			getItem_ = s_scriptCtrl.CodeObject.item
		End If
	End Function
		
	'''将json字符串解析成json对象
	'p_json:要解析的字符串
	Public Function [Decode](Byval p_json)
		'On Error Resume Next

		initScriptCtrl(p_json)

		If IsObject( s_scriptCtrl.CodeObject.result ) Then
			Dim t_object : Set t_object = s_scriptCtrl.CodeObject.result
			If t_object.isArray() Then ''作为数组处理
				Dim t_keys1, t_arr1(), t_path1, t_temp1
				Set t_keys1 = t_object.keys()
				ReDim t_arr1(t_keys1.length-1)
				For t_i = 0 To t_keys1.length-1
					t_path1 = "[" & Cstr(t_i) & "]"
					Call assign( t_temp1, getItem_(t_path1) )
					If IsObject(t_temp1) Then
						Set t_arr1(t_i) = t_temp1
					Else
						t_arr1(t_i) = t_temp1
					End If
				Next
				[Decode] = t_arr1
			Else ''作为Dictionary处理
				Dim t_item : Set t_item = Server.CreateObject( s_cfg.Environment("Scripting.Dictionary") )
				Dim t_keys2, t_obj_val, t_obj_key, t_path2, t_temp2
				Set t_keys2 = t_object.keys()
				For t_i = 0 To t_keys2.length-1
					t_obj_key = t_keys2.get(t_i)
					t_path2 = "[""" & Replace(t_obj_key, """", "\""") & """]"
					Call assign( t_temp2, getItem_(t_path2) )
					If IsObject(t_temp2) Then
						Set t_item(t_obj_key) = t_temp2
					Else
						t_item(t_obj_key) = t_temp2
					End If
				Next
				Set [Decode] = t_item
			End If
		Else
			'''标量直接返回
			[Decode] = s_scriptCtrl.CodeObject.result
		End If
		
		If Err.Number <> 0 Then
			Set [Decode] = Nothing
		End If
	End Function
End Class
%>